home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / efs / efs-ovwrt.el.z / efs-ovwrt.el
Encoding:
Text File  |  1998-05-21  |  4.4 KB  |  122 lines
  1. ;; -*-Emacs-Lisp-*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;
  4. ;; File:         efs-ovwrt.el
  5. ;; Release:      $efs release: 1.15 $
  6. ;; Version:      #Revision: 1.2 $
  7. ;; RCS:
  8. ;; Description:  Utilities for overwriting functions with new definitions.
  9. ;; Author:       Andy Norman <ange@hplb.hpl.hp.com>
  10. ;;
  11. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  12.  
  13. ;;; Although used by efs, these utilities could be of general use to other
  14. ;;; packages too. Keeping them separate from the main efs program
  15. ;;; makes it easier for other programs to require them.
  16.  
  17. (provide 'efs-ovwrt)
  18. (eval-when-compile
  19.   (condition-case nil
  20.       (require 'advice)
  21.     (error)))
  22.  
  23. (defconst efs-ovwrt-version
  24.   (concat (substring "$efs release: 1.15 $" 14 -2)
  25.       "/"
  26.       (substring "#Revision: 1.2 $" 11 -2)))
  27.  
  28. (defvar efs-overwrite-fmt
  29.   "Note: This function has been modified to work with %s.")
  30.  
  31. ;; Make the byte compiler happy.
  32. (defvar file-name-handler-alist)
  33. (defvar inhibit-file-name-handlers)
  34. (defvar inhibit-file-name-operation)
  35.  
  36. (defun efs-safe-documentation (fun)
  37.   "A documentation function that isn't quite as fragile."
  38.   (condition-case ()
  39.       (documentation fun)
  40.     (error nil)))
  41.  
  42. (defun efs-overwrite-fn (package fun &optional newfun)
  43.   "Overwrites a function with a new definition from PACKAGE.
  44. PACKAGE should be a string. The the function to be overwritten is FUN.
  45. The new definition is obtained from the optional NEWFUN. If ommitted,
  46. NEWFUN is taken to be PACKAGE-FUN. The original definition is stored in
  47. PACKAGE-real-FUN. The original documentation is placed on the new
  48. definition suitably augmented."
  49.   (let* ((name (symbol-name fun))
  50.      (saved (intern (concat package "-real-" name)))
  51.      (new (or newfun (intern (concat package "-" name))))
  52.      (nfun (symbol-function new))
  53.      (exec-directory (if (or (equal (nth 3 command-line-args) "dump")
  54.                  (equal (nth 4 command-line-args) "dump"))
  55.                  "../etc/"
  56.                exec-directory)))             
  57.     
  58.     (while (symbolp nfun)
  59.       (setq nfun (symbol-function nfun)))
  60.     
  61.     ;; Interpose the new function between the function symbol and the
  62.     ;; original definition of the function symbol AT TIME OF FIRST LOAD.
  63.     ;; We must only redefine the symbol-function of FUN the very first
  64.     ;; time, to avoid blowing away stuff that overloads FUN after this.
  65.     
  66.     ;; We direct the function symbol to the new function symbol
  67.     ;; rather than function definition to allow reloading of this file or
  68.     ;; redefining of the individual function (e.g., during debugging)
  69.     ;; later after some other code has been loaded on top of our stuff.
  70.     
  71.     (or (fboundp saved)
  72.     (let ((advised-p (and (featurep 'advice)
  73.                   (ad-is-advised fun))))
  74.       (if advised-p (ad-deactivate fun))
  75.       (fset saved (symbol-function fun))
  76.       (fset fun new)
  77.       (if advised-p (ad-activate fun))))
  78.     
  79.     ;; Rewrite the doc string on the new function.  This should
  80.     ;; be done every time the file is loaded (or a function is redefined),
  81.     ;; because the underlying overloaded function may have changed its doc
  82.     ;; string.
  83.     
  84.     (let* ((doc-str (efs-safe-documentation saved))
  85.        (ndoc-str (concat doc-str (and doc-str "\n")
  86.                  (format efs-overwrite-fmt package))))
  87.       
  88.       (cond ((listp nfun)
  89.          ;; Probe to test whether function is in preloaded read-only
  90.          ;; memory, and if so make writable copy:
  91.          (condition-case nil
  92.          (setcar nfun (car nfun))
  93.            (error
  94.         (setq nfun (copy-sequence nfun)) ; shallow copy only
  95.         (fset new nfun)))
  96.          (let ((ndoc-cdr (nthcdr 2 nfun)))
  97.            (if (stringp (car ndoc-cdr))
  98.            ;; Replace the existing docstring.
  99.            (setcar ndoc-cdr ndoc-str)
  100.          ;; There is no docstring.  Insert the overwrite msg.
  101.          (setcdr ndoc-cdr (cons (car ndoc-cdr) (cdr ndoc-cdr)))
  102.          (setcar ndoc-cdr (format efs-overwrite-fmt package)))))
  103.         (t
  104.          ;; it's an emacs19 compiled-code object
  105.          ;;
  106.          ;; XEmacs: can't use append on a compiled function
  107.          ;; as the latter is no longer a vector.  Use the
  108.          ;; accessor functions instead.
  109.          (let ((new-code (nconc
  110.                   (list (compiled-function-arglist nfun)
  111.                     (compiled-function-instructions nfun)
  112.                     (compiled-function-constants nfun)
  113.                     (compiled-function-stack-depth nfun)
  114.                     ndoc-str)))
  115.            spec)
  116.            (if (setq spec (compiled-function-interactive nfun))
  117.            (setq new-code (nconc new-code (list (nth 1 spec)))))
  118.            (fset new (apply 'make-byte-code new-code))))))))
  119.  
  120.  
  121. ;;; end of efs-ovwrt.el
  122.